home *** CD-ROM | disk | FTP | other *** search
/ Linux Cubed Series 3: Developer Tools / Linux Cubed Series 3 - Developer Tools.iso / devel / lang / lisp / stk-3.002 / stk-3 / STk-3.1 / Src / proc.c < prev    next >
Encoding:
C/C++ Source or Header  |  1996-05-13  |  3.0 KB  |  136 lines
  1. /*
  2.  *
  3.  * p r o c . c            -- 
  4.  *
  5.  * Copyright ⌐ 1993-1996 Erick Gallesio - I3S-CNRS/ESSI <eg@unice.fr>
  6.  * 
  7.  *
  8.  * Permission to use, copy, and/or distribute this software and its
  9.  * documentation for any purpose and without fee is hereby granted, provided
  10.  * that both the above copyright notice and this permission notice appear in
  11.  * all copies and derived works.  Fees for distribution or use of this
  12.  * software or derived works may only be charged with express written
  13.  * permission of the copyright holder.  
  14.  * This software is provided ``as is'' without express or implied warranty.
  15.  *
  16.  * This software is a derivative work of other copyrighted softwares; the
  17.  * copyright notices of these softwares are placed in the file COPYRIGHTS
  18.  *
  19.  *
  20.  *           Author: Erick Gallesio [eg@kaolin.unice.fr]
  21.  *    Creation date: 15-Nov-1993 22:02
  22.  * Last file update: 13-May-1996 22:41
  23.  */
  24.  
  25. #include "stk.h"
  26. #include "extend.h"
  27.  
  28. /**** Section 6.9 ****/
  29.  
  30. int STk_is_thunk(SCM obj)
  31. {
  32.   switch (TYPE(obj)) {
  33.     case tc_closure:    /* We can be more clever here.... */
  34. #ifdef USE_STKLOS
  35.     case tc_instance:
  36. #endif
  37.     case tc_subr_0:
  38.     case tc_subr_0_or_1: return TRUE;
  39.   }
  40.   return FALSE;
  41. }
  42.  
  43.  
  44. PRIMITIVE STk_procedurep(SCM obj)
  45. {
  46.   switch (TYPE(obj)) {
  47.     case tc_subr_0:     
  48.     case tc_subr_1:     
  49.     case tc_subr_2:  
  50.     case tc_subr_3:    
  51.     case tc_subr_0_or_1:    
  52.     case tc_subr_1_or_2:
  53.     case tc_subr_2_or_3:
  54.     case tc_lambda:    
  55.     case tc_lsubr:        
  56.     case tc_ssubr:
  57.     case tc_closure:
  58.     case tc_cont:
  59.     case tc_apply:
  60.     case tc_call_cc:
  61.     case tc_dynwind: 
  62. #ifdef USE_STKLOS
  63.     case tc_instance:
  64.     case tc_next_method:
  65. #endif
  66. #ifdef USE_TK
  67.     case tc_tkcommand:
  68. #endif
  69.             return Truth;
  70.     default:         if (EXTENDEDP(obj))
  71.                     return STk_extended_procedurep(obj) ? Truth : Ntruth;
  72.             else 
  73.               return Ntruth;
  74.   }
  75. }
  76.  
  77.  
  78. static SCM general_map(SCM l, int map, int len)
  79. {
  80.   register int i;
  81.   SCM res = NIL,*tmp = &res;
  82.   SCM fct, args;
  83.  
  84.   if (NCONSP(l)) goto error;
  85.  
  86.   fct  = CAR(l);
  87.   len -= 1;
  88.   args = STk_vector(CDR(l), len);
  89.  
  90.   for ( ; ; ) {
  91.     /* Build parameter list */
  92.     for (l=NIL, i=len-1; i >= 0; i--) {
  93.       if (NULLP(VECT(args)[i])) return res;
  94.       if (NCONSP(VECT(args)[i])) goto error;
  95.  
  96.       l             = Cons(CAR(VECT(args)[i]), l);
  97.       VECT(args)[i] = CDR(VECT(args)[i]);
  98.     }
  99.  
  100.     /* See if it's a map or a for-each call */
  101.     if (map) {
  102.       *tmp = Cons(Apply(fct, l), NIL);
  103.       tmp  = &CDR(*tmp);
  104.     }
  105.     else Apply(fct, l);
  106.   }
  107. error:
  108.   { 
  109.     char buff[50];
  110.     sprintf(buff, "%s: malformed list", map? "map" : "for-each");
  111.     Err(buff, l);
  112.   }
  113. }
  114.  
  115. PRIMITIVE STk_map(SCM l, int len)
  116. {
  117.   return general_map(l, 1, len);
  118. }
  119.  
  120. PRIMITIVE STk_for_each(SCM l, int len)
  121. {
  122.   return general_map(l, 0, len);
  123. }
  124.  
  125. PRIMITIVE STk_procedure_body(SCM proc)
  126. {
  127.   return TYPEP(proc, tc_closure) ? Cons(Sym_lambda, proc->storage_as.closure.code)
  128.                      : Ntruth;
  129. }
  130.  
  131. PRIMITIVE STk_procedure_environment(SCM proc)
  132. {
  133.   return TYPEP(proc, tc_closure) ? STk_makeenv(proc->storage_as.closure.env,0)
  134.                      : Ntruth;    
  135. }
  136.